home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0407.ZIP / IO20DEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1986-05-02  |  18KB  |  527 lines
  1. program IO20DEMO ;
  2.   { This program demonstrates Turbo Pascal I/O routines
  3.     developed by Wm Meacham.
  4.     Revised 4/18/86 }
  5.  
  6.   { For CP/M, compile to COM file with End address of $7000. }
  7.  
  8. {$c-,v-}
  9. {$i io20.inc }
  10. {$i date20.inc }
  11.  
  12. var
  13.     choice           : integer ;    { to get menu choice }
  14.     quitnow          : boolean ;    { to get user Y/N input }
  15.  
  16. { ------------------------------------------------------------ }
  17.  
  18. procedure title_screen ;
  19.     begin
  20.         clrscr;
  21.         write_str ('-------------------',30,6) ;
  22.         write_str ('                   ',30,7) ;
  23.         write_str ('   Demonstration   ',30,8) ;
  24.         write_str ('        of         ',30,9) ;
  25.         write_str ('   Turbo Pascal    ',30,10) ;
  26.         write_str ('   I/O routines    ',30,11) ;
  27.         write_str ('                   ',30,12) ;
  28.         write_str ('-------------------',30,13) ;
  29.         write_str ('    Reliance Software Services',23,18) ;
  30.         write_str ('1004 Elm Street, Austin, Tx  78703',23,19) ;
  31.         write_str ('   Public Domain - No Copyright',23,21) ;
  32.         fld := 0 ;
  33.         hard_pause ;
  34.         if fld = maxint then halt
  35.     end ; { proc title_screen }
  36.  
  37. { ------------------------------------------------------------ }
  38.  
  39. procedure display_menu ;
  40. begin
  41.     clrscr ;
  42.     write_str('I/O DEMONSTRATION',32,3) ;
  43.     write_str('MAIN MENU',36,4) ;
  44.     write_str('Please select:',26,6) ;
  45.     write_str('1    Display instructions',26,8) ;
  46.     write_str('2    Data entry and display demo for',26,10) ;
  47.     write_str('Strings, Integers, Reals and Booleans',31,11) ;
  48.     write_str('3    Data entry and display demo for Dates',26,13) ;
  49.     write_str('ESC  Exit the program',26,15) ;
  50.     write_str('==>',26,17)
  51. end ; { proc display_menu }
  52.  
  53. { ------------------------------------------------------------ }
  54.  
  55. procedure display_instructions ;
  56. begin
  57.     clrscr;
  58.     write_str('   COMMAND             Labelled     Arrow   Ctrl     Function',7,1) ;
  59.     write_str('                         key         key    key      key (IBM)',7,2) ;
  60.     write_str('   ------              --------     -----   ----     ---------',7,3) ;
  61.     write_str('*  DELETE character      Del,       left      S         F1',7,4) ;
  62.     write_str('   to left             Backspace',7,5) ;
  63.     write_str('*  DELETE entire                              Y         F2',7,6) ;
  64.     write_str('   entry',7,7) ;
  65.     write_str('*  MOVE DOWN            Return,     down      X         F4',7,8) ;
  66.     write_str('   a line               Enter',7,9) ;
  67.     write_str('*  MOVE UP                           up       E         F3',7,10) ;
  68.     write_str('   a line',7,11) ;
  69.     write_str('*  PAGE FORWARD                     PgDn      C         F8',7,12) ;
  70.     write_str('   to next screen                   (IBM)',7,13) ;
  71.     write_str('*  PAGE BACKWARD                    PgUp      R         F7',7,14) ;
  72.     write_str('   to prev. screen                  (IBM)',7,15) ;
  73.     write_str('*  CANCEL data entry     Esc',7,16) ;
  74.     write_str('*  TO ENTER DATA:    Type the data & press Enter or another',7,18) ;
  75.     write_str('cursor movement key.',28,19) ;
  76.     write_str('*  TO ENTER YES/NO:  Type "Y" or "N;" don''t press Enter.',7,20) ;
  77.     write_str('*  TO ENTER A DATE:  Type the month & press Enter, type the day',7,21) ;
  78.     write_str('& press Enter, type the year & press Enter.',28,22) ;
  79.     hard_pause ;
  80.     fld := 1 { reset FLD for calling proc }
  81. end ; { proc display_instructions }
  82.  
  83. { ------------------------------------------------------------ }
  84.  
  85. procedure io_demo ;
  86.   { demonstrate I/O of strings, integers, reals and booleans }
  87.  
  88. var
  89.     first, last, addr1, addr2, city,
  90.           state, zip : str_type ;   { for string demo }
  91.     i1, i2, i3, itot : integer ;    { for integer demo }
  92.     r1, r2, r3, rtot : real ;       { for real demo }
  93.     b1, b2, b3, b4   : boolean ;    { for boolean demo }
  94.  
  95. { ==================== }
  96.  
  97. procedure init_io_vars ;
  98.   { Initializes global variables }
  99.     begin
  100.         first := '' ;
  101.         last  := '' ;
  102.         addr1 := '' ;
  103.         addr2 := '' ;
  104.         city  := '' ;
  105.         state := '' ;
  106.         zip   := '' ;
  107.         i1 := 0 ;
  108.         i2 := 0 ;
  109.         i3 := 0 ;
  110.         itot := 0 ;
  111.         r1 := 0 ;
  112.         r2 := 0 ;
  113.         r3 := 0 ;
  114.         rtot := 0 ;
  115.         b1 := false ;
  116.         b2 := false ;
  117.         b3 := false ;
  118.         b4 := false
  119.     end ; { proc init_io_vars }
  120.  
  121. { ==================== }
  122.  
  123. procedure strings ;
  124.   { This procedure demonstrates reading and writing strings. }
  125.  
  126.     var
  127.         i  : integer ; { For loop control }
  128.         ok : boolean ; { Whether zip code is numeric }
  129.  
  130.     begin
  131.         clrscr ;
  132.         write ('SCREEN ', scrn, ' -- STRINGS') ;
  133.         write_str ('First name:',9,8) ;
  134.         write_str (first,21,8 ) ;
  135.         write_str ('Last name:',9,9) ;
  136.         write_str (last,21,9) ;
  137.         write_str ('Address 1:',9,10) ;
  138.         write_str (addr1,21,10) ;
  139.         write_str ('Address 2:',9,11) ;
  140.         write_str (addr2,21,11) ;
  141.         write_str ('City:',9,12) ;
  142.         write_str (city,21,12) ;
  143.         write_str ('State:',9,13) ;
  144.         write_str (state,21,13) ;
  145.         write_str ('Zip:',9,14) ;
  146.         write_str (zip,21,14) ;
  147.         fld := 1 ;
  148.         repeat
  149.                 case fld of
  150.                   1: read_str (first, 15, 21, 8) ;
  151.                   2: read_str (last, 10, 21, 9) ;
  152.                   3: read_str (addr1, 15, 21, 10) ;
  153.                   4: read_str (addr2, 15, 21, 11) ;
  154.                   5: read_str (city, 15, 21, 12) ;
  155.                   6: read_str (state, 2, 21, 13) ;
  156.                   7: begin
  157.                        repeat
  158.                            read_str (zip, 5, 21, 14) ;
  159.                            ok := true ;
  160.                            if not (zip = '') then
  161.                                begin
  162.                                    if length (zip) < 5 then
  163.                                            ok := false
  164.                                    else
  165.                                            for i:= 1 to 5 do
  166.                                                if (zip[i] <'0')
  167.                                                or (zip[i] >'9') then
  168.                                                    ok := false
  169.                                end ;
  170.                            if not ok then
  171.                              begin
  172.                                show_msg ('MUST BE NUMERIC OR NOT ENTERED') ;
  173.                                zip := '' ;
  174.                                fld := 7
  175.                              end
  176.                        until ok ;
  177.                      end ; { 7: }
  178.                 end ; { case }
  179.         until (fld < 1) or (fld > 7) ;
  180.         do_scrn_ctl
  181.     end ; { proc strings }
  182.  
  183. { ==================== }
  184.  
  185. procedure integers ;
  186.   { This procedure demonstrates reading & writing integers. }
  187.  
  188.     procedure sum_int ;
  189.         begin
  190.             itot := i1 + i2 + i3 ;
  191.             write_int (itot, 5, 13, 12)
  192.         end ;
  193.  
  194.     begin { integers }
  195.         clrscr ;
  196.         write ('SCREEN ', scrn, ' -- INTEGERS') ;
  197.         write_str ('==>', 9, 8) ;
  198.         write_int (i1,4,14,8) ;
  199.         write_str ('==>', 9, 9) ;
  200.         write_int (i2,4,14,9) ;
  201.         write_str ('==>', 9, 10) ;
  202.         write_int (i3,4,14,10) ;
  203.         write_str ('TOTAL', 7, 12) ;
  204.         write_int (itot,5,13,12) ;
  205.         fld := 1 ;
  206.         repeat
  207.                 case fld of
  208.                   1: begin
  209.                        read_int (i1, 4, 14, 8) ;
  210.                        sum_int ;
  211.                      end ;
  212.                   2: begin
  213.                        read_int (i2, 4, 14, 9) ;
  214.                        sum_int ;
  215.                      end ;
  216.                   3: begin
  217.                        read_int (i3, 4, 14, 10) ;
  218.                        sum_int ;
  219.                      end ;
  220.                   4: pause ;
  221.                 end ; { case }
  222.         until (fld < 1) or (fld > 4 ) ;
  223.         do_scrn_ctl
  224.     end ; { proc integers }
  225.  
  226. { ==================== }
  227.  
  228. procedure reals ;
  229.   { This procedure demonstrates reading & writing reals. }
  230.  
  231.     const
  232.         tot  = 11 ;
  233.         frac = 3  ;
  234.  
  235.     procedure sum_real ;
  236.         begin
  237.             rtot := r1 + r2 + r3 ;
  238.             write_real (rtot, tot+1, frac, 13, 12)
  239.         end ;
  240.  
  241.     begin { proc reals }
  242.         clrscr ;
  243.         write ('SCREEN ', scrn, ' -- REALS') ;
  244.         write_str ('==>', 9, 8) ;
  245.         write_real (r1,tot,frac,14,8) ;
  246.         write_str ('==>', 9, 9) ;
  247.         write_real (r2,tot,frac,14,9) ;
  248.         write_str ('==>', 9, 10) ;
  249.         write_real (r3,tot,frac,14,10) ;
  250.         write_str ('TOTAL', 7, 12) ;
  251.         write_real (rtot,12,3,13,12) ;
  252.         fld := 1 ;
  253.         repeat
  254.                 case fld of
  255.                   1: begin
  256.                        read_real (r1, tot,frac, 14, 8) ;
  257.                        sum_real ;
  258.                      end ;
  259.                   2: begin
  260.                        read_real (r2, tot,frac, 14, 9) ;
  261.                        sum_real ;
  262.                      end ;
  263.                   3: begin
  264.                        read_real (r3, tot,frac, 14, 10) ;
  265.                        sum_real ;
  266.                      end ;
  267.                   4: pause ;
  268.                 end ; { CASE }
  269.         until (fld < 1) or (fld > 4 ) ;
  270.         do_scrn_ctl
  271.     end ; { proc reals }
  272.  
  273. { ==================== }
  274.  
  275. procedure booleans ;
  276.   { This procedure demonstrates reading & writing booleans }
  277.     begin
  278.         clrscr;
  279.         write ('SCREEN ', scrn, ' -- BOOLEANS') ;
  280.         write_str ('TYPE OF CO-BORROWER.  Type "Y" for all that apply.',3,8) ;
  281.         write_str ('"No" will be assumed if you just press <RETURN>.',3,9) ;
  282.         write_str ('1 - Another person will be jointly obligated with borrower',5,10) ;
  283.         write_str ('2 - Borrower is relying on income of another person',5,11) ;
  284.         write_str ('3 - Married, living in a community property state',5,12) ;
  285.         write_bool (b1, 71, 10) ;
  286.         write_bool (b2, 71, 11) ;
  287.         write_bool (b3, 71, 12) ;
  288.         write_str ('Epimenides the Cretan says, "All Cretans are liars!"  Is he lying?',3,14) ;
  289.         write_bool (b4, 71, 14) ;
  290.         fld := 1 ;
  291.         repeat
  292.             case fld of
  293.               1: read_bool (b1, 71, 10) ;
  294.               2: read_bool (b2, 71, 11) ;
  295.               3: read_bool (b3, 71, 12) ;
  296.               4: read_bool (b4, 71, 14) ;
  297.               5: pause ;
  298.             end ; { case }
  299.         until (fld <1) or (fld > 5) ;
  300.         do_scrn_ctl
  301.     end ; { booleans }
  302.  
  303. { ==================== }
  304.  
  305. procedure final_screen ;
  306.   { The final screen -- demonstrates proc Read_YN }
  307.     var
  308.         more : boolean ;
  309.     begin
  310.         clrscr ;
  311.         write_str ('End of demonstration.',20, 10) ;
  312.         write_str ('Do it again?',20, 12) ;
  313.         read_yn (more, 34, 12) ;
  314.         if more then
  315.             scrn := 1
  316.         else
  317.             scrn := succ(scrn)
  318.     end ; { proc final_screen }
  319.  
  320. { ==================== }
  321.  
  322. begin { ----- proc io_demo ----- }
  323.     scrn := 1 ;
  324.     init_io_vars ;
  325.     repeat
  326.         case scrn of
  327.           1 : strings  ;
  328.           2 : integers ;
  329.           3 : reals ;
  330.           4 : booleans ;
  331.           5 : final_screen
  332.         end ; { case }
  333.         if scrn < 1 then
  334.               scrn := 1           { no going backward from first screen }
  335.         else if scrn > 6 then
  336.               scrn := 5           { trap ESC }
  337.     until scrn > 5 ;
  338.     fld := 1 ;                    { reset FLD for calling proc }
  339. end ; { proc io_demo }
  340.  
  341. { ------------------------------------------------------------------------ }
  342.  
  343. procedure date_demo ;
  344.   { demonstrates the things you can do with dates }
  345.  
  346. const
  347.     null_jul : juldate = (yr:0 ; day:0) ;
  348.     blanks   : string[10] = '          ' ;
  349.  
  350. var
  351.     date1,
  352.     date2,
  353.     temp1,
  354.     temp2    : date ;
  355.     workjul  : juldate ;
  356.     juldtst  : juldatestring ;
  357.     dtst     : datestring ;
  358.     diff     : string[7] ;
  359.     n        : integer ;
  360.     prevfld  : integer ;
  361.  
  362. { ==================== }
  363.  
  364. procedure display_diff ;
  365.   begin
  366.     if equal_date (date1,null_date)
  367.     or equal_date (date2,null_date) then
  368.         for n := 18 to 21 do
  369.             clrline (16,n)
  370.     else if equal_date(date1,date2) then
  371.       begin
  372.         write_str ('The dates are equal',16,18) ;
  373.         write ('':20) ;
  374.         for n := 20 to 21 do
  375.             clrline (16,n)
  376.       end
  377.     else
  378.       begin
  379.         write_date (date1,16,18) ;
  380.         if greater_date(date1,date2) = 1 then
  381.           begin
  382.             write (' is later than ') ;
  383.             temp1 := date2 ;
  384.             temp2 := date1
  385.           end
  386.         else
  387.           begin
  388.             write (' is earlier than ') ;
  389.             temp1 := date1 ;
  390.             temp2 := date2
  391.           end ;
  392.         dtst := mk_dt_st(date2) ;
  393.         write (dtst) ;
  394.         write ('':20) ;
  395.         write_str ('There are ',16,20) ;
  396.         str(date_diff(temp1,temp2):7:0,diff) ;
  397.         diff := purgech(diff,' ') ;
  398.         write (diff,' days (about ') ;
  399.         write (month_diff(temp1,temp2)) ;
  400.         write (' months) between') ;
  401.         write ('':20) ;
  402.         write_str ('the two dates.',16,21)
  403.       end
  404.   end ;
  405.  
  406. { ==================== }
  407.  
  408. begin { proc date_demo }
  409.     clrscr ;
  410.     write_str('Enter two dates, press ESC to quit.',16,1) ;
  411.     write_str('DATE 1               DATE 2',32,3) ;
  412.     write_str('------               ------',32,4) ;
  413.     write_str('==>                  ==>',26,6) ;
  414.     write_str('Julian date:',17,8) ;
  415.     write_str('Next day:',20,10) ;
  416.     write_str('Previous day:',16,12) ;
  417.     write_str('Leap year?',19,14) ;
  418.     write_str('=============================================',16,16) ;
  419.     date1 := null_date ;
  420.     date2 := null_date ;
  421.     fld := 1 ;
  422.     repeat
  423.         case fld of
  424.          1: begin
  425.               prevfld := 1 ;
  426.               read_date (date1,30,6) ;
  427.               if not (equal_date(date1,null_date)) then
  428.                 begin
  429.                   greg_to_jul (date1,workjul) ;
  430.                   juldtst := mk_jul_dt_st (workjul) ;
  431.                   write_str (juldtst,32,8) ;
  432.                   temp1 := date1 ;
  433.                   next_day (temp1) ;
  434.                   write_date (temp1,30,10) ;
  435.                   temp1 := date1 ;
  436.                   prev_day (temp1) ;
  437.                   write_date (temp1,30,12) ;
  438.                   write_bool (leapyear(date1.yr),32,14) ;
  439.                 end
  440.               else
  441.                   for n := 8 to 14 do
  442.                       write_str (blanks,30,n) ;
  443.               display_diff
  444.             end ; { 1 }
  445.          2: begin
  446.               prevfld := 2 ;
  447.               read_date (date2,51,6) ;
  448.               if not (equal_date(date2,null_date)) then
  449.                 begin
  450.                   greg_to_jul (date2,workjul) ;
  451.                   juldtst := mk_jul_dt_st (workjul) ;
  452.                   write_str (juldtst,53,8) ;
  453.                   temp1 := date2 ;
  454.                   next_day (temp1) ;
  455.                   write_date (temp1,51,10) ;
  456.                   temp1 := date2 ;
  457.                   prev_day (temp1) ;
  458.                   write_date (temp1,51,12) ;
  459.                   write_bool (leapyear(date2.yr),53,14) ;
  460.                 end
  461.               else
  462.                   for n := 8 to 14 do
  463.                       write_str (blanks,51,n) ;
  464.               display_diff
  465.             end ; { 2 }
  466.          3: begin
  467.               prevfld := 3 ;
  468.               pause
  469.             end
  470.         end ; { case }
  471.         if fld < 1 then                           { can't go back from 1 }
  472.             fld := 1
  473.         else if (fld > 3) and (fld < maxint) then
  474.           begin
  475.             if prevfld = 3 then
  476.                 fld := 1                          { back to beginning from 3 }
  477.             else
  478.                 fld := 3                          { trap next_page }
  479.           end
  480.     until fld = maxint ;
  481.     fld := 1  { reset FLD for calling proc }
  482. end ; { proc date_demo }
  483.  
  484. { ------------------------------------------------------------ }
  485.  
  486. begin { --- program IO20DEMO --- }
  487.     title_screen ;
  488.     repeat
  489.         display_menu ;
  490.         repeat
  491.             fld := 1 ;
  492.             choice := 0 ;
  493.             read_int (choice,1, 31,17) ;
  494.             if fld < 1 then choice := 0 ;
  495.             if fld = maxint then
  496.               begin
  497.                 write_str (' ',31,17) ;
  498.                 write_str ('QUIT NOW? (Y/N)',26,19) ;
  499.                 read_yn (quitnow,42,19) ;
  500.                 if not quitnow then
  501.                   begin
  502.                     fld := 1 ;
  503.                     choice := 0 ;
  504.                     clrline (26,19)
  505.                   end
  506.               end ;
  507.         until (choice in [1 .. 3]) or (fld = maxint) ;
  508.         if not (fld = maxint) then
  509.             case choice of
  510.               1: display_instructions ;
  511.               2: io_demo ;
  512.               3: date_demo ;
  513.             else
  514.                  beep
  515.             end  { case }
  516.     until fld = maxint ;
  517.     clrscr ;
  518.     write_str ('Thank you for trying the Reliance I/O Demonstration',12,5) ;
  519.     write_str ('Program.  Please send me your comments and suggestions.',12,6) ;
  520.     write_str ('Bill Meacham',30,10) ;
  521.     write_str ('Reliance Software Services',24,11) ;
  522.     write_str ('1004 Elm Street',29,12) ;
  523.     write_str ('Austin, Tx  78703',28,13) ;
  524.     writeln ; writeln
  525. end.
  526.  
  527.